{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.RelPitch
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Relative pitch (and relative duration) note list monad.
--
--------------------------------------------------------------------------------


module Lirio.RelPitch
  (


    NoteList
  , notelist

  , relative


  ) where

import Lirio.Base.Overloading
import Lirio.Base.Pitch
import qualified Lirio.Base.RelDuration as RD
import Lirio.Score

import Control.Applicative hiding ( empty )
import Data.Monoid hiding ( (<>) )


newtype State = State { rel_pitch :: Pitch }



newtype NoteList a = NoteList { getNoteList :: RD.DRelative State a }




instance Functor NoteList where
  fmap f = NoteList . fmap f . getNoteList


instance Applicative NoteList where
  pure a    = NoteList $ pure a
  mf <*> ma = NoteList $ getNoteList mf <*> getNoteList ma


instance Monad NoteList where
  return   = pure
  ma >>= k = NoteList $ getNoteList ma >>= (getNoteList . k)
 


instance Monoid a => Monoid (NoteList a) where
  mempty          = pure mempty
  ma `mappend` mb = NoteList $ getNoteList ma `mappend` getNoteList mb





getPitch :: NoteList Pitch
getPitch = NoteList $ get >>= return . rel_pitch

setPitch :: Pitch -> NoteList ()
setPitch p = NoteList $ modify (\s -> s { rel_pitch = p })


-- | NoteLists are /run/ within a Score.
--
notelist :: NoteList a -> Score a
notelist ma = withScore $ \r -> 
    let s0      = State { rel_pitch = relative_pitch r }
        (a,_,w) = RD.runNotelist s0 (getNoteList ma) 
    in (a, w)


deltaPitch :: Pitch -> NoteList Pitch
deltaPitch p = 
    getPitch >>= \p0 -> 
    let i  = lyOctaveDist p0 p 
        p1 = setOctave i p
    in setPitch p >> return p1



--------------------------------------------------------------------------------
-- Overloading instances

instance HasCommandM NoteList where
  command = NoteList . command

instance HasNewlineM NoteList where
  newline = NoteList $ newline


instance NoteListM NoteList


instance GenericMarkM NoteList where
  genericMark = NoteList . genericMark 


instance GenericEventM NoteList where
  genericEvent doc d = NoteList $ genericEvent doc d




instance HasRestM   NoteList
instance HasSpacerM NoteList


type instance Pch NoteList = Pitch


instance NoteM NoteList where
  note p d = deltaPitch p >>= \pd -> (NoteList $ note pd d)



instance ChordM NoteList where
  chord ps d = mapM deltaPitch ps >>= \psd -> (NoteList $ chord psd d)


instance GroupingM NoteList where
  prefix d = NoteList . prefix d . getNoteList
  suffix d = NoteList . suffix d . getNoteList




-- Note - If we call @relative@ in a score it implies score state
-- has /current pitch/ as well a the note list...
--



relative :: Pitch -> Score () -> Score ()
relative p ma = 
    local (\e -> e { relative_pitch = p' }) ( command "relative" <+> ma)
  where
    p' = displaceOctave (-3) p

